home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / src / tclUnixAZ.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-10  |  54.3 KB  |  2,218 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCL_2
  3. #endif
  4.  
  5. /* 
  6.  * tclUnixAZ.c --
  7.  *
  8.  *    This file contains the top-level command procedures for
  9.  *    commands in the Tcl core that require UNIX facilities
  10.  *    such as files and process execution.  Much of the code
  11.  *    in this file is based on earlier versions contributed
  12.  *    by Karl Lehenbauer, Mark Diekhans and Peter da Silva.
  13.  *
  14.  * Copyright (c) 1991-1993 The Regents of the University of California.
  15.  * All rights reserved.
  16.  *
  17.  * Permission is hereby granted, without written agreement and without
  18.  * license or royalty fees, to use, copy, modify, and distribute this
  19.  * software and its documentation for any purpose, provided that the
  20.  * above copyright notice and the following two paragraphs appear in
  21.  * all copies of this software.
  22.  * 
  23.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  24.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  25.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  26.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27.  *
  28.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  29.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  30.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  31.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  32.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  33.  */
  34.  
  35. #ifndef lint
  36. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUnixAZ.c,v 1.70 93/09/24 16:47:39 ouster Exp $ SPRITE (Berkeley)";
  37. #endif /* not lint */
  38.  
  39. #ifdef THINK_C
  40. #    include <unix.h>
  41. #endif
  42.  
  43. #include "tclInt.h"
  44. #include "tclUnix.h"
  45.  
  46. #ifdef macintosh
  47.  
  48. #    include <Events.h>
  49. #    include <files.h>
  50.  
  51. #endif
  52.  
  53. /*
  54.  * The variable below caches the name of the current working directory
  55.  * in order to avoid repeated calls to getcwd.  The string is malloc-ed.
  56.  * NULL means the cache needs to be refreshed.
  57.  */
  58.  
  59. static char *currentDir =  NULL;
  60.  
  61. /*
  62.  * If the system doesn't define the EWOULDBLOCK errno, just #define it
  63.  * to a bogus value that will never occur.
  64.  */
  65.  
  66. #ifndef EWOULDBLOCK
  67. #define EWOULDBLOCK -1901
  68. #endif
  69.  
  70. /*
  71.  * Prototypes for local procedures defined in this file:
  72.  */
  73.  
  74. static int        CleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
  75.                 int numPids, int *pidPtr, int errorId,
  76.                 int keepNewline));
  77. static char *        GetFileType _ANSI_ARGS_((int mode));
  78. static char *        GetOpenMode _ANSI_ARGS_((Tcl_Interp *interp,
  79.                 char *string, int *modePtr));
  80. static int        StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
  81.                 char *varName, struct stat *statPtr));
  82.  
  83. /*
  84.  *----------------------------------------------------------------------
  85.  *
  86.  * Tcl_CdCmd --
  87.  *
  88.  *    This procedure is invoked to process the "cd" Tcl command.
  89.  *    See the user documentation for details on what it does.
  90.  *
  91.  * Results:
  92.  *    A standard Tcl result.
  93.  *
  94.  * Side effects:
  95.  *    See the user documentation.
  96.  *
  97.  *----------------------------------------------------------------------
  98.  */
  99.  
  100.     /* ARGSUSED */
  101. int
  102. Tcl_CdCmd(dummy, interp, argc, argv)
  103.     ClientData dummy;            /* Not used. */
  104.     Tcl_Interp *interp;            /* Current interpreter. */
  105.     int argc;                /* Number of arguments. */
  106.     char **argv;            /* Argument strings. */
  107. {
  108.     char *dirName;
  109.     Tcl_DString buffer;
  110.     int result;
  111.  
  112.     if (argc > 2) {
  113.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  114.         " dirName\"", (char *) NULL);
  115.     return TCL_ERROR;
  116.     }
  117.  
  118.     if (argc == 2) {
  119.     dirName = argv[1];
  120.     } else {
  121.     dirName = "~";
  122.     }
  123.     dirName = Tcl_TildeSubst(interp, dirName, &buffer);
  124.     if (dirName == NULL) {
  125.     return TCL_ERROR;
  126.     }
  127.     if (currentDir != NULL) {
  128.     ckfree(currentDir);
  129.     currentDir = NULL;
  130.     }
  131.     result = TCL_OK;
  132. #ifdef UNDONE
  133.     if (chdir(dirName) != 0) {
  134.     Tcl_AppendResult(interp, "couldn't change working directory to \"",
  135.         dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
  136.     result = TCL_ERROR;
  137.     }
  138. #else
  139.     Tcl_AppendResult(interp, "couldn't change working directory to \"",
  140.         dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
  141.     result = TCL_ERROR;
  142. #endif
  143.  
  144.     Tcl_DStringFree(&buffer);
  145.     return result;
  146. }
  147.  
  148. /*
  149.  *----------------------------------------------------------------------
  150.  *
  151.  * Tcl_CloseCmd --
  152.  *
  153.  *    This procedure is invoked to process the "close" Tcl command.
  154.  *    See the user documentation for details on what it does.
  155.  *
  156.  * Results:
  157.  *    A standard Tcl result.
  158.  *
  159.  * Side effects:
  160.  *    See the user documentation.
  161.  *
  162.  *----------------------------------------------------------------------
  163.  */
  164.  
  165.     /* ARGSUSED */
  166. int
  167. Tcl_CloseCmd(dummy, interp, argc, argv)
  168.     ClientData dummy;            /* Not used. */
  169.     Tcl_Interp *interp;            /* Current interpreter. */
  170.     int argc;                /* Number of arguments. */
  171.     char **argv;            /* Argument strings. */
  172. {
  173.     OpenFile *oFilePtr;
  174.     int result = TCL_OK;
  175.     FILE *f;
  176.  
  177.     if (argc != 2) {
  178.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  179.         " fileId\"", (char *) NULL);
  180.     return TCL_ERROR;
  181.     }
  182.     if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) {
  183.     return TCL_ERROR;
  184.     }
  185.     oFilePtr = tclOpenFiles[fileno(f)];
  186.     tclOpenFiles[fileno(f)] = NULL;
  187.  
  188.     /*
  189.      * First close the file (in the case of a process pipeline, there may
  190.      * be two files, one for the pipe at each end of the pipeline).
  191.      */
  192.  
  193.     if (oFilePtr->f2 != NULL) {
  194.     clearerr(oFilePtr->f2);
  195.     if (fclose(oFilePtr->f2) == EOF) {
  196.         Tcl_AppendResult(interp, "error closing \"", argv[1],
  197.             "\": ", Tcl_PosixError(interp), "\n", (char *) NULL);
  198.         result = TCL_ERROR;
  199.     }
  200.     }
  201.     clearerr(oFilePtr->f);
  202.     if (fclose(oFilePtr->f) == EOF) {
  203.     Tcl_AppendResult(interp, "error closing \"", argv[1],
  204.         "\": ", Tcl_PosixError(interp), "\n", (char *) NULL);
  205.     result = TCL_ERROR;
  206.     }
  207.  
  208.     /*
  209.      * If the file was a connection to a pipeline, clean up everything
  210.      * associated with the child processes.
  211.      */
  212.  
  213.     if (oFilePtr->numPids > 0) {
  214.     if (CleanupChildren(interp, oFilePtr->numPids, oFilePtr->pidPtr,
  215.         oFilePtr->errorId, 0) != TCL_OK) {
  216.         result = TCL_ERROR;
  217.     }
  218.     }
  219.  
  220.     ckfree((char *) oFilePtr);
  221.     return result;
  222. }
  223.  
  224. /*
  225.  *----------------------------------------------------------------------
  226.  *
  227.  * Tcl_EofCmd --
  228.  *
  229.  *    This procedure is invoked to process the "eof" Tcl command.
  230.  *    See the user documentation for details on what it does.
  231.  *
  232.  * Results:
  233.  *    A standard Tcl result.
  234.  *
  235.  * Side effects:
  236.  *    See the user documentation.
  237.  *
  238.  *----------------------------------------------------------------------
  239.  */
  240.  
  241.     /* ARGSUSED */
  242. int
  243. Tcl_EofCmd(notUsed, interp, argc, argv)
  244.     ClientData notUsed;            /* Not used. */
  245.     Tcl_Interp *interp;            /* Current interpreter. */
  246.     int argc;                /* Number of arguments. */
  247.     char **argv;            /* Argument strings. */
  248. {
  249.     FILE *f;
  250.  
  251.     if (argc != 2) {
  252.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  253.         " fileId\"", (char *) NULL);
  254.     return TCL_ERROR;
  255.     }
  256.     if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) {
  257.     return TCL_ERROR;
  258.     }
  259.     if (feof(f)) {
  260.     interp->result = "1";
  261.     } else {
  262.     interp->result = "0";
  263.     }
  264.     return TCL_OK;
  265. }
  266.  
  267. /*
  268.  *----------------------------------------------------------------------
  269.  *
  270.  * Tcl_ExecCmd --
  271.  *
  272.  *    This procedure is invoked to process the "exec" Tcl command.
  273.  *    See the user documentation for details on what it does.
  274.  *
  275.  * Results:
  276.  *    A standard Tcl result.
  277.  *
  278.  * Side effects:
  279.  *    See the user documentation.
  280.  *
  281.  *----------------------------------------------------------------------
  282.  */
  283.  
  284.     /* ARGSUSED */
  285. int
  286. Tcl_ExecCmd(dummy, interp, argc, argv)
  287.     ClientData dummy;            /* Not used. */
  288.     Tcl_Interp *interp;            /* Current interpreter. */
  289.     int argc;                /* Number of arguments. */
  290.     char **argv;            /* Argument strings. */
  291. {
  292.     int outputId;            /* File id for output pipe.  -1
  293.                      * means command overrode. */
  294.     int errorId;            /* File id for temporary file
  295.                      * containing error output. */
  296.     int *pidPtr;
  297.     int numPids, result, keepNewline;
  298.     int firstWord;
  299.  
  300.     /*
  301.      * Check for a leading "-keepnewline" argument.
  302.      */
  303.  
  304.     keepNewline = 0;
  305.     for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-');
  306.         firstWord++) {
  307.     if (strcmp(argv[firstWord], "-keepnewline") == 0) {
  308.         keepNewline = 1;
  309.     } else if (strcmp(argv[firstWord], "--") == 0) {
  310.         firstWord++;
  311.         break;
  312.     } else {
  313.         Tcl_AppendResult(interp, "bad switch \"", argv[firstWord],
  314.             "\": must be -keepnewline or --", (char *) NULL);
  315.         return TCL_ERROR;
  316.     }
  317.     }
  318.  
  319.     if (argc <= firstWord) {
  320.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  321.         " ?switches? arg ?arg ...?\"", (char *) NULL);
  322.     return TCL_ERROR;
  323.     }
  324.  
  325.     /*
  326.      * See if the command is to be run in background;  if so, create
  327.      * the command, detach it, and return a list of pids.
  328.      */
  329.  
  330.     if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) {
  331.     int i;
  332.     char id[50];
  333.  
  334.     argc--;
  335.     argv[argc] = NULL;
  336.     numPids = Tcl_CreatePipeline(interp, argc-firstWord, argv+firstWord,
  337.         &pidPtr, (int *) NULL, (int *) NULL, (int *) NULL);
  338.     if (numPids < 0) {
  339.         return TCL_ERROR;
  340.     }
  341.     Tcl_DetachPids(numPids, pidPtr);
  342.     for (i = 0; i < numPids; i++) {
  343.         sprintf(id, "%d", pidPtr[i]);
  344.         Tcl_AppendElement(interp, id);
  345.     }
  346.     ckfree((char *) pidPtr);
  347.     return TCL_OK;
  348.     }
  349.  
  350.     /*
  351.      * Create the command's pipeline.
  352.      */
  353.  
  354.     numPids = Tcl_CreatePipeline(interp, argc-firstWord, argv+firstWord,
  355.         &pidPtr, (int *) NULL, &outputId, &errorId);
  356.     if (numPids < 0) {
  357.     return TCL_ERROR;
  358.     }
  359.  
  360.     /*
  361.      * Read the child's output (if any) and put it into the result.
  362.      */
  363.  
  364.     result = TCL_OK;
  365.     if (outputId != -1) {
  366.     while (1) {
  367. #        define BUFFER_SIZE 1000
  368.         char buffer[BUFFER_SIZE+1];
  369.         int count;
  370.     
  371.         count = read(outputId, buffer, (size_t) BUFFER_SIZE);
  372.     
  373.         if (count == 0) {
  374.         break;
  375.         }
  376.         if (count < 0) {
  377.         Tcl_ResetResult(interp);
  378.         Tcl_AppendResult(interp,
  379.             "error reading from output pipe: ",
  380.             Tcl_PosixError(interp), (char *) NULL);
  381.         result = TCL_ERROR;
  382.         break;
  383.         }
  384.         buffer[count] = 0;
  385.         Tcl_AppendResult(interp, buffer, (char *) NULL);
  386.     }
  387.     close(outputId);
  388.     }
  389.  
  390.     if (CleanupChildren(interp, numPids, pidPtr, errorId, keepNewline)
  391.         != TCL_OK) {
  392.     result = TCL_ERROR;
  393.     }
  394.     return result;
  395. }
  396.  
  397. /*
  398.  *----------------------------------------------------------------------
  399.  *
  400.  * Tcl_ExitCmd --
  401.  *
  402.  *    This procedure is invoked to process the "exit" Tcl command.
  403.  *    See the user documentation for details on what it does.
  404.  *
  405.  * Results:
  406.  *    A standard Tcl result.
  407.  *
  408.  * Side effects:
  409.  *    See the user documentation.
  410.  *
  411.  *----------------------------------------------------------------------
  412.  */
  413.  
  414.     /* ARGSUSED */
  415. int
  416. Tcl_ExitCmd(dummy, interp, argc, argv)
  417.     ClientData dummy;            /* Not used. */
  418.     Tcl_Interp *interp;            /* Current interpreter. */
  419.     int argc;                /* Number of arguments. */
  420.     char **argv;            /* Argument strings. */
  421. {
  422.     int value;
  423.  
  424.     if ((argc != 1) && (argc != 2)) {
  425.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  426.         " ?returnCode?\"", (char *) NULL);
  427.     return TCL_ERROR;
  428.     }
  429.     if (argc == 1) {
  430.     exit(0);
  431.     }
  432.     if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) {
  433.     return TCL_ERROR;
  434.     }
  435.     exit(value);
  436.     /*NOTREACHED*/
  437.     return TCL_OK;            /* Better not ever reach this! */
  438. }
  439.  
  440. /*
  441.  *----------------------------------------------------------------------
  442.  *
  443.  * Tcl_FileCmd --
  444.  *
  445.  *    This procedure is invoked to process the "file" Tcl command.
  446.  *    See the user documentation for details on what it does.
  447.  *
  448.  * Results:
  449.  *    A standard Tcl result.
  450.  *
  451.  * Side effects:
  452.  *    See the user documentation.
  453.  *
  454.  *----------------------------------------------------------------------
  455.  */
  456.  
  457.     /* ARGSUSED */
  458. int
  459. Tcl_FileCmd(dummy, interp, argc, argv)
  460.     ClientData dummy;            /* Not used. */
  461.     Tcl_Interp *interp;            /* Current interpreter. */
  462.     int argc;                /* Number of arguments. */
  463.     char **argv;            /* Argument strings. */
  464. {
  465.     char *p;
  466.     int length, statOp, result;
  467.     int mode = 0;            /* Initialized only to prevent
  468.                      * compiler warning message. */
  469.     struct stat statBuf;
  470.     char *fileName, c;
  471.     Tcl_DString buffer;
  472.  
  473.     if (argc < 3) {
  474.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  475.         " option name ?arg ...?\"", (char *) NULL);
  476.     return TCL_ERROR;
  477.     }
  478.     c = argv[1][0];
  479.     length = strlen(argv[1]);
  480.     result = TCL_OK;
  481.  
  482.     /*
  483.      * First handle operations on the file name.
  484.      */
  485.  
  486.     fileName = Tcl_TildeSubst(interp, argv[2], &buffer);
  487.     if (fileName == NULL) {
  488.     result = TCL_ERROR;
  489.     goto done;
  490.     }
  491.     if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) {
  492.     if (argc != 3) {
  493.         argv[1] = "dirname";
  494.         not3Args:
  495.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  496.             " ", argv[1], " name\"", (char *) NULL);
  497.         result = TCL_ERROR;
  498.         goto done;
  499.     }
  500. #ifdef macintosh
  501.     p = strrchr(fileName, ':');
  502. #else
  503.     p = strrchr(fileName, '/');
  504. #endif
  505.     if (p == NULL) {
  506. #ifdef macintosh
  507.         interp->result = "";
  508. #else
  509.         interp->result = ".";
  510. #endif
  511.     } else if (p == fileName) {
  512. #ifdef macintosh
  513.         interp->result = "";
  514. #else
  515.         interp->result = "/";
  516. #endif
  517.     } else {
  518.         *p = 0;
  519.         Tcl_SetResult(interp, fileName, TCL_VOLATILE);
  520. #ifdef macintosh
  521.         *p = ':';
  522. #else
  523.         *p = '/';
  524. #endif
  525.     }
  526.     goto done;
  527.     } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0)
  528.         && (length >= 2)) {
  529.     char *lastSlash;
  530.  
  531.     if (argc != 3) {
  532.         argv[1] = "rootname";
  533.         goto not3Args;
  534.     }
  535.     p = strrchr(fileName, '.');
  536. #ifdef macintosh
  537.     lastSlash = strrchr(fileName, ':');
  538. #else
  539.     lastSlash = strrchr(fileName, '/');
  540. #endif
  541.     if ((p == NULL) || ((lastSlash != NULL) && (lastSlash > p))) {
  542.         Tcl_SetResult(interp, fileName, TCL_VOLATILE);
  543.     } else {
  544.         *p = 0;
  545.         Tcl_SetResult(interp, fileName, TCL_VOLATILE);
  546.         *p = '.';
  547.     }
  548.     goto done;
  549.     } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0)
  550.         && (length >= 3)) {
  551.     char *lastSlash;
  552.  
  553.     if (argc != 3) {
  554.         argv[1] = "extension";
  555.         goto not3Args;
  556.     }
  557.     p = strrchr(fileName, '.');
  558. #ifdef macintosh
  559.     lastSlash = strrchr(fileName, ':');
  560. #else
  561.     lastSlash = strrchr(fileName, '/');
  562. #endif
  563.     if ((p != NULL) && ((lastSlash == NULL) || (lastSlash < p))) {
  564.         Tcl_SetResult(interp, p, TCL_VOLATILE);
  565.     }
  566.     goto done;
  567.     } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0)
  568.         && (length >= 2)) {
  569.     if (argc != 3) {
  570.         argv[1] = "tail";
  571.         goto not3Args;
  572.     }
  573. #ifdef macintosh
  574.     p = strrchr(fileName, ':');
  575. #else
  576.     p = strrchr(fileName, '/');
  577. #endif
  578.     if (p != NULL) {
  579.         Tcl_SetResult(interp, p+1, TCL_VOLATILE);
  580.     } else {
  581.         Tcl_SetResult(interp, fileName, TCL_VOLATILE);
  582.     }
  583.     goto done;
  584.     }
  585.  
  586.     /*
  587.      * Next, handle operations that can be satisfied with the "access"
  588.      * kernel call.
  589.      */
  590.  
  591.     if (fileName == NULL) {
  592.     result = TCL_ERROR;
  593.     goto done;
  594.     }
  595.     if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0)
  596.         && (length >= 5)) {
  597.     if (argc != 3) {
  598.         argv[1] = "readable";
  599.         goto not3Args;
  600.     }
  601.     mode = R_OK;
  602.     checkAccess:
  603.     if (access(fileName, mode) == -1) {
  604.         interp->result = "0";
  605.     } else {
  606.         interp->result = "1";
  607.     }
  608.     goto done;
  609.     } else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) {
  610.     if (argc != 3) {
  611.         argv[1] = "writable";
  612.         goto not3Args;
  613.     }
  614.     mode = W_OK;
  615.     goto checkAccess;
  616.     } else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0)
  617.         && (length >= 3)) {
  618.     if (argc != 3) {
  619.         argv[1] = "executable";
  620.         goto not3Args;
  621.     }
  622.     mode = X_OK;
  623.     goto checkAccess;
  624.     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)
  625.         && (length >= 3)) {
  626.     if (argc != 3) {
  627.         argv[1] = "exists";
  628.         goto not3Args;
  629.     }
  630.     mode = F_OK;
  631.     goto checkAccess;
  632.     }
  633.  
  634.     /*
  635.      * Lastly, check stuff that requires the file to be stat-ed.
  636.      */
  637.  
  638.     if ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) {
  639.     if (argc != 3) {
  640.         argv[1] = "atime";
  641.         goto not3Args;
  642.     }
  643.     if (stat(fileName, &statBuf) == -1) {
  644.         goto badStat;
  645.     }
  646.     sprintf(interp->result, "%ld", statBuf.st_atime);
  647.     goto done;
  648.     } else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0)
  649.         && (length >= 3)) {
  650.     if (argc != 3) {
  651.         argv[1] = "isdirectory";
  652.         goto not3Args;
  653.     }
  654.     statOp = 2;
  655.     } else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0)
  656.         && (length >= 3)) {
  657.     if (argc != 3) {
  658.         argv[1] = "isfile";
  659.         goto not3Args;
  660.     }
  661.     statOp = 1;
  662.     } else if ((c == 'l') && (strncmp(argv[1], "lstat", length) == 0)) {
  663.     if (argc != 4) {
  664.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  665.             " lstat name varName\"", (char *) NULL);
  666.         result = TCL_ERROR;
  667.         goto done;
  668.     }
  669.  
  670.     if (lstat(fileName, &statBuf) == -1) {
  671.         Tcl_AppendResult(interp, "couldn't lstat \"", argv[2],
  672.             "\": ", Tcl_PosixError(interp), (char *) NULL);
  673.         result = TCL_ERROR;
  674.         goto done;
  675.     }
  676.     result = StoreStatData(interp, argv[3], &statBuf);
  677.     goto done;
  678.     } else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) {
  679.     if (argc != 3) {
  680.         argv[1] = "mtime";
  681.         goto not3Args;
  682.     }
  683.     if (stat(fileName, &statBuf) == -1) {
  684.         goto badStat;
  685.     }
  686.     sprintf(interp->result, "%ld", statBuf.st_mtime);
  687.     goto done;
  688.     } else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) {
  689.     if (argc != 3) {
  690.         argv[1] = "owned";
  691.         goto not3Args;
  692.     }
  693.     statOp = 0;
  694.     } else if ((c == 'r') && (strncmp(argv[1], "readlink", length) == 0)
  695.         && (length >= 5)) {
  696.     char linkValue[MAXPATHLEN+1];
  697.     int linkLength;
  698.  
  699.     if (argc != 3) {
  700.         argv[1] = "readlink";
  701.         goto not3Args;
  702.     }
  703.  
  704.     /*
  705.      * If S_IFLNK isn't defined it means that the machine doesn't
  706.      * support symbolic links, so the file can't possibly be a
  707.      * symbolic link.  Generate an EINVAL error, which is what
  708.      * happens on machines that do support symbolic links when
  709.      * you invoke readlink on a file that isn't a symbolic link.
  710.      */
  711.  
  712. #if !defined(S_IFLNK) || defined(macintosh)
  713.     linkLength = -1;
  714.     errno = EINVAL;
  715. #else
  716.     linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1);
  717. #endif /* S_IFLNK */
  718.     if (linkLength == -1) {
  719.         Tcl_AppendResult(interp, "couldn't readlink \"", argv[2],
  720.             "\": ", Tcl_PosixError(interp), (char *) NULL);
  721.         result = TCL_ERROR;
  722.         goto done;
  723.     }
  724.     linkValue[linkLength] = 0;
  725.     Tcl_SetResult(interp, linkValue, TCL_VOLATILE);
  726.     goto done;
  727.     } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
  728.         && (length >= 2)) {
  729.     if (argc != 3) {
  730.         argv[1] = "size";
  731.         goto not3Args;
  732.     }
  733.     if (stat(fileName, &statBuf) == -1) {
  734.         goto badStat;
  735.     }
  736.     sprintf(interp->result, "%ld", statBuf.st_size);
  737.     goto done;
  738.     } else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0)
  739.         && (length >= 2)) {
  740.     if (argc != 4) {
  741.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  742.             " stat name varName\"", (char *) NULL);
  743.         result = TCL_ERROR;
  744.         goto done;
  745.     }
  746.  
  747.     if (stat(fileName, &statBuf) == -1) {
  748.         badStat:
  749.         Tcl_AppendResult(interp, "couldn't stat \"", argv[2],
  750.             "\": ", Tcl_PosixError(interp), (char *) NULL);
  751.         result = TCL_ERROR;
  752.         goto done;
  753.     }
  754.     result = StoreStatData(interp, argv[3], &statBuf);
  755.     goto done;
  756.     } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0)
  757.         && (length >= 2)) {
  758.     if (argc != 3) {
  759.         argv[1] = "type";
  760.         goto not3Args;
  761.     }
  762.     if (lstat(fileName, &statBuf) == -1) {
  763.         goto badStat;
  764.     }
  765.     interp->result = GetFileType((int) statBuf.st_mode);
  766.     goto done;
  767.     } else {
  768.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  769.         "\": should be atime, dirname, executable, exists, ",
  770.         "extension, isdirectory, isfile, lstat, mtime, owned, ",
  771.         "readable, readlink, ",
  772.         "root, size, stat, tail, type, ",
  773.         "or writable",
  774.         (char *) NULL);
  775.     result = TCL_ERROR;
  776.     goto done;
  777.     }
  778.     if (stat(fileName, &statBuf) == -1) {
  779.     interp->result = "0";
  780.     goto done;
  781.     }
  782.     switch (statOp) {
  783.     case 0:
  784. #ifdef macintosh
  785.         mode = 1;
  786. #else
  787.         mode = (geteuid() == statBuf.st_uid);
  788. #endif
  789.         break;
  790.     case 1:
  791.         mode = S_ISREG(statBuf.st_mode);
  792.         break;
  793.     case 2:
  794.         mode = S_ISDIR(statBuf.st_mode);
  795.         break;
  796.     }
  797.     if (mode) {
  798.     interp->result = "1";
  799.     } else {
  800.     interp->result = "0";
  801.     }
  802.  
  803.     done:
  804.     Tcl_DStringFree(&buffer);
  805.     return result;
  806. }
  807.  
  808. /*
  809.  *----------------------------------------------------------------------
  810.  *
  811.  * StoreStatData --
  812.  *
  813.  *    This is a utility procedure that breaks out the fields of a
  814.  *    "stat" structure and stores them in textual form into the
  815.  *    elements of an associative array.
  816.  *
  817.  * Results:
  818.  *    Returns a standard Tcl return value.  If an error occurs then
  819.  *    a message is left in interp->result.
  820.  *
  821.  * Side effects:
  822.  *    Elements of the associative array given by "varName" are modified.
  823.  *
  824.  *----------------------------------------------------------------------
  825.  */
  826.  
  827. static int
  828. StoreStatData(interp, varName, statPtr)
  829.     Tcl_Interp *interp;            /* Interpreter for error reports. */
  830.     char *varName;            /* Name of associative array variable
  831.                      * in which to store stat results. */
  832.     struct stat *statPtr;        /* Pointer to buffer containing
  833.                      * stat data to store in varName. */
  834. {
  835.     char string[30];
  836.  
  837.     sprintf(string, "%d", statPtr->st_dev);
  838.     if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG)
  839.         == NULL) {
  840.     return TCL_ERROR;
  841.     }
  842.     sprintf(string, "%d", statPtr->st_ino);
  843.     if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG)
  844.         == NULL) {
  845.     return TCL_ERROR;
  846.     }
  847.     sprintf(string, "%d", statPtr->st_mode);
  848.     if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG)
  849.         == NULL) {
  850.     return TCL_ERROR;
  851.     }
  852.     sprintf(string, "%d", statPtr->st_nlink);
  853.     if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG)
  854.         == NULL) {
  855.     return TCL_ERROR;
  856.     }
  857.     sprintf(string, "%d", statPtr->st_uid);
  858.     if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG)
  859.         == NULL) {
  860.     return TCL_ERROR;
  861.     }
  862.     sprintf(string, "%d", statPtr->st_gid);
  863.     if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG)
  864.         == NULL) {
  865.     return TCL_ERROR;
  866.     }
  867.     sprintf(string, "%ld", statPtr->st_size);
  868.     if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG)
  869.         == NULL) {
  870.     return TCL_ERROR;
  871.     }
  872.     sprintf(string, "%ld", statPtr->st_atime);
  873.     if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)
  874.         == NULL) {
  875.     return TCL_ERROR;
  876.     }
  877.     sprintf(string, "%ld", statPtr->st_mtime);
  878.     if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)
  879.         == NULL) {
  880.     return TCL_ERROR;
  881.     }
  882.     sprintf(string, "%ld", statPtr->st_ctime);
  883.     if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG)
  884.         == NULL) {
  885.     return TCL_ERROR;
  886.     }
  887.     if (Tcl_SetVar2(interp, varName, "type",
  888.         GetFileType((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) {
  889.     return TCL_ERROR;
  890.     }
  891.     return TCL_OK;
  892. }
  893.  
  894. /*
  895.  *----------------------------------------------------------------------
  896.  *
  897.  * GetFileType --
  898.  *
  899.  *    Given a mode word, returns a string identifying the type of a
  900.  *    file.
  901.  *
  902.  * Results:
  903.  *    A static text string giving the file type from mode.
  904.  *
  905.  * Side effects:
  906.  *    None.
  907.  *
  908.  *----------------------------------------------------------------------
  909.  */
  910.  
  911. static char *
  912. GetFileType(mode)
  913.     int mode;
  914. {
  915.     if (S_ISREG(mode)) {
  916.     return "file";
  917.     } else if (S_ISDIR(mode)) {
  918.     return "directory";
  919.     } else if (S_ISCHR(mode)) {
  920.     return "characterSpecial";
  921.     } else if (S_ISBLK(mode)) {
  922.     return "blockSpecial";
  923.     } else if (S_ISFIFO(mode)) {
  924.     return "fifo";
  925.     } else if (S_ISLNK(mode)) {
  926.     return "link";
  927.     } else if (S_ISSOCK(mode)) {
  928.     return "socket";
  929.     }
  930.     return "unknown";
  931. }
  932.  
  933. /*
  934.  *----------------------------------------------------------------------
  935.  *
  936.  * Tcl_FlushCmd --
  937.  *
  938.  *    This procedure is invoked to process the "flush" Tcl command.
  939.  *    See the user documentation for details on what it does.
  940.  *
  941.  * Results:
  942.  *    A standard Tcl result.
  943.  *
  944.  * Side effects:
  945.  *    See the user documentation.
  946.  *
  947.  *----------------------------------------------------------------------
  948.  */
  949.  
  950.     /* ARGSUSED */
  951. int
  952. Tcl_FlushCmd(notUsed, interp, argc, argv)
  953.     ClientData notUsed;            /* Not used. */
  954.     Tcl_Interp *interp;            /* Current interpreter. */
  955.     int argc;                /* Number of arguments. */
  956.     char **argv;            /* Argument strings. */
  957. {
  958.     FILE *f;
  959.  
  960.     if (argc != 2) {
  961.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  962.         " fileId\"", (char *) NULL);
  963.     return TCL_ERROR;
  964.     }
  965.     if (Tcl_GetOpenFile(interp, argv[1], 1, 1, &f) != TCL_OK) {
  966.     return TCL_ERROR;
  967.     }
  968.     clearerr(f);
  969.     if (fflush(f) == EOF) {
  970.     Tcl_AppendResult(interp, "error flushing \"", argv[1],
  971.         "\": ", Tcl_PosixError(interp), (char *) NULL);
  972.     return TCL_ERROR;
  973.     }
  974.     return TCL_OK;
  975. }
  976.  
  977. /*
  978.  *----------------------------------------------------------------------
  979.  *
  980.  * Tcl_GetsCmd --
  981.  *
  982.  *    This procedure is invoked to process the "gets" Tcl command.
  983.  *    See the user documentation for details on what it does.
  984.  *
  985.  * Results:
  986.  *    A standard Tcl result.
  987.  *
  988.  * Side effects:
  989.  *    See the user documentation.
  990.  *
  991.  *----------------------------------------------------------------------
  992.  */
  993.  
  994.     /* ARGSUSED */
  995. int
  996. Tcl_GetsCmd(notUsed, interp, argc, argv)
  997.     ClientData notUsed;            /* Not used. */
  998.     Tcl_Interp *interp;            /* Current interpreter. */
  999.     int argc;                /* Number of arguments. */
  1000.     char **argv;            /* Argument strings. */
  1001. {
  1002. #   define BUF_SIZE 200
  1003.     char buffer[BUF_SIZE+1];
  1004.     int totalCount, done, flags;
  1005.     FILE *f;
  1006.  
  1007.     if ((argc != 2) && (argc != 3)) {
  1008.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1009.         " fileId ?varName?\"", (char *) NULL);
  1010.     return TCL_ERROR;
  1011.     }
  1012.     if (Tcl_GetOpenFile(interp, argv[1], 0, 1, &f) != TCL_OK) {
  1013.     return TCL_ERROR;
  1014.     }
  1015.  
  1016.     /*
  1017.      * We can't predict how large a line will be, so read it in
  1018.      * pieces, appending to the current result or to a variable.
  1019.      */
  1020.  
  1021.     totalCount = 0;
  1022.     done = 0;
  1023.     flags = 0;
  1024.     clearerr(f);
  1025.     while (!done) {
  1026.     register int c, count;
  1027.     register char *p;
  1028.  
  1029.     for (p = buffer, count = 0; count < BUF_SIZE-1; count++, p++) {
  1030.         c = getc(f);
  1031.         if (c == EOF) {
  1032.         if (ferror(f)) {
  1033.             /*
  1034.              * If the file is in non-blocking mode, return any
  1035.              * bytes that were read before a block would occur.
  1036.              */
  1037.  
  1038.             if ((errno == EWOULDBLOCK)
  1039.                 && ((count > 0 || totalCount > 0))) {
  1040.             done = 1;
  1041.             break;
  1042.             }
  1043.             Tcl_ResetResult(interp);
  1044.             Tcl_AppendResult(interp, "error reading \"", argv[1],
  1045.                 "\": ", Tcl_PosixError(interp), (char *) NULL);
  1046.             return TCL_ERROR;
  1047.         } else if (feof(f)) {
  1048.             if ((totalCount == 0) && (count == 0)) {
  1049.             totalCount = -1;
  1050.             }
  1051.             done = 1;
  1052.             break;
  1053.         }
  1054.         }
  1055. #ifdef macintosh
  1056.         if (c == '\r' || c == '\n') {
  1057. #else
  1058.         if (c == '\n') {
  1059. #endif
  1060.         done = 1;
  1061.         break;
  1062.         }
  1063.         *p = c;
  1064.     }
  1065.     *p = 0;
  1066.     if (argc == 2) {
  1067.         Tcl_AppendResult(interp, buffer, (char *) NULL);
  1068.     } else {
  1069.         if (Tcl_SetVar(interp, argv[2], buffer, flags|TCL_LEAVE_ERR_MSG)
  1070.             == NULL) {
  1071.         return TCL_ERROR;
  1072.         }
  1073.         flags = TCL_APPEND_VALUE;
  1074.     }
  1075.     totalCount += count;
  1076.     }
  1077.  
  1078.     if (argc == 3) {
  1079.     sprintf(interp->result, "%d", totalCount);
  1080.     }
  1081.     return TCL_OK;
  1082. }
  1083.  
  1084. /*
  1085.  *----------------------------------------------------------------------
  1086.  *
  1087.  * Tcl_OpenCmd --
  1088.  *
  1089.  *    This procedure is invoked to process the "open" Tcl command.
  1090.  *    See the user documentation for details on what it does.
  1091.  *
  1092.  * Results:
  1093.  *    A standard Tcl result.
  1094.  *
  1095.  * Side effects:
  1096.  *    See the user documentation.
  1097.  *
  1098.  *----------------------------------------------------------------------
  1099.  */
  1100.  
  1101.     /* ARGSUSED */
  1102. int
  1103. Tcl_OpenCmd(notUsed, interp, argc, argv)
  1104.     ClientData notUsed;            /* Not used. */
  1105.     Tcl_Interp *interp;            /* Current interpreter. */
  1106.     int argc;                /* Number of arguments. */
  1107.     char **argv;            /* Argument strings. */
  1108.     {
  1109.     int pipeline, fd, mode, prot, readWrite, permissions;
  1110.     char *access;
  1111.     FILE *f, *f2;
  1112.  
  1113.     if ((argc < 2) || (argc > 4)) {
  1114.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1115.         " filename ?access? ?permissions?\"", (char *) NULL);
  1116.     return TCL_ERROR;
  1117.     }
  1118.     prot = 0666;
  1119.     if (argc == 2) {
  1120.     mode = O_RDONLY;
  1121.     access = "r";
  1122.     } else {
  1123.     access = GetOpenMode(interp, argv[2], &mode);
  1124.     if (access == NULL) {
  1125.         return TCL_ERROR;
  1126.     }
  1127.     if (argc == 4) {
  1128.         if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) {
  1129.         return TCL_ERROR;
  1130.         }
  1131.     }
  1132.     }
  1133.  
  1134.     f = f2 = NULL;
  1135.     readWrite = mode & (O_RDWR|O_RDONLY|O_WRONLY);
  1136.     if (readWrite == O_RDONLY) {
  1137.     permissions = TCL_FILE_READABLE;
  1138.     } else if (readWrite == O_WRONLY) {
  1139.     permissions = TCL_FILE_WRITABLE;
  1140.     } else {
  1141.     permissions = TCL_FILE_READABLE|TCL_FILE_WRITABLE;
  1142.     }
  1143.  
  1144.     pipeline = 0;
  1145.     if (argv[1][0] == '|') {
  1146.     pipeline = 1;
  1147.     }
  1148.  
  1149.     /*
  1150.      * Open the file or create a process pipeline.
  1151.      */
  1152.  
  1153.     if (!pipeline) {
  1154.     char *fileName;
  1155.     Tcl_DString buffer, buffer2;
  1156.     
  1157.     Tcl_DStringInit(&buffer2);
  1158.  
  1159.     fileName = Tcl_TildeSubst(interp, argv[1], &buffer);
  1160.     if (fileName == NULL) {
  1161.         return TCL_ERROR;
  1162.     }
  1163.  
  1164.     fd = open(fileName, mode, prot);
  1165.     
  1166.     Tcl_DStringFree(&buffer);
  1167.     Tcl_DStringFree(&buffer2);
  1168.     
  1169.     if (fd < 0) {
  1170.         Tcl_AppendResult(interp, "couldn't open \"", argv[1],
  1171.             "\": ", Tcl_PosixError(interp), (char *) NULL);
  1172.         return TCL_ERROR;
  1173.     }
  1174.     f = fdopen(fd, access);
  1175.  
  1176.     if (f == NULL) {
  1177.         close(fd);
  1178.         return TCL_ERROR;
  1179.     }
  1180.     Tcl_EnterFile(interp, f, permissions);
  1181.     } else {
  1182.         Tcl_AppendResult(interp, "can not pipe in macintosh version", (char *) NULL);
  1183.         return TCL_ERROR;
  1184. #ifndef macintosh
  1185.     int *inPipePtr, *outPipePtr;
  1186.     int cmdArgc, inPipe, outPipe, numPids, *pidPtr, errorId;
  1187.     char **cmdArgv;
  1188.     OpenFile *oFilePtr;
  1189.  
  1190.     if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) {
  1191.         return TCL_ERROR;
  1192.     }
  1193.     inPipePtr = (permissions & TCL_FILE_WRITABLE) ? &inPipe : NULL;
  1194.     outPipePtr = (permissions & TCL_FILE_READABLE) ? &outPipe : NULL;
  1195.     inPipe = outPipe = errorId = -1;
  1196.     numPids = Tcl_CreatePipeline(interp, cmdArgc, cmdArgv,
  1197.         &pidPtr, inPipePtr, outPipePtr, &errorId);
  1198.     ckfree((char *) cmdArgv);
  1199.     if (numPids < 0) {
  1200.         pipelineError:
  1201.         if (f != NULL) {
  1202.         fclose(f);
  1203.         }
  1204.         if (f2 != NULL) {
  1205.         fclose(f2);
  1206.         }
  1207.         if (numPids > 0) {
  1208.         Tcl_DetachPids(numPids, pidPtr);
  1209.         ckfree((char *) pidPtr);
  1210.         }
  1211.         if (errorId != -1) {
  1212.         close(errorId);
  1213.         }
  1214.         return TCL_ERROR;
  1215.     }
  1216.     if (permissions & TCL_FILE_READABLE) {
  1217.         if (outPipe == -1) {
  1218.         if (inPipe != -1) {
  1219.             close(inPipe);
  1220.         }
  1221.         Tcl_AppendResult(interp, "can't read output from command:",
  1222.             " standard output was redirected", (char *) NULL);
  1223.         goto pipelineError;
  1224.         }
  1225.         f = fdopen(outPipe, "r");
  1226.     }
  1227.     if (permissions & TCL_FILE_WRITABLE) {
  1228.         if (inPipe == -1) {
  1229.         Tcl_AppendResult(interp, "can't write input to command:",
  1230.             " standard input was redirected", (char *) NULL);
  1231.         goto pipelineError;
  1232.         }
  1233.         if (f != NULL) {
  1234.         f2 = fdopen(inPipe, "w");
  1235.         } else {
  1236.         f = fdopen(inPipe, "w");
  1237.         }
  1238.     }
  1239.     Tcl_EnterFile(interp, f, permissions);
  1240.     oFilePtr = tclOpenFiles[fileno(f)];
  1241.     oFilePtr->f2 = f2;
  1242.     oFilePtr->numPids = numPids;
  1243.     oFilePtr->pidPtr = pidPtr;
  1244.     oFilePtr->errorId = errorId;
  1245. #endif
  1246.     }
  1247.     return TCL_OK;
  1248. }
  1249.  
  1250. /*
  1251.  *----------------------------------------------------------------------
  1252.  *
  1253.  * GetOpenMode --
  1254.  *
  1255.  *    description.
  1256.  *
  1257.  * Results:
  1258.  *    Normally, sets *modePtr to an access mode for passing to "open",
  1259.  *    and returns a string that can be used as the access mode in a
  1260.  *    subsequent call to "fdopen".  If an error occurs, then returns
  1261.  *    NULL and sets interp->result to an error message.
  1262.  *
  1263.  * Side effects:
  1264.  *    None.
  1265.  *
  1266.  * Special note:
  1267.  *    This code is based on a prototype implementation contributed
  1268.  *    by Mark Diekhans.
  1269.  *
  1270.  *----------------------------------------------------------------------
  1271.  */
  1272.  
  1273. static char *
  1274. GetOpenMode(interp, string, modePtr)
  1275.     Tcl_Interp *interp;            /* Interpreter to use for error
  1276.                      * reporting. */
  1277.     char *string;            /* Mode string, e.g. "r+" or
  1278.                      * "RDONLY CREAT". */
  1279.     int *modePtr;            /* Where to store mode corresponding
  1280.                      * to string. */
  1281. {
  1282.     int mode, modeArgc, c, i, gotRW;
  1283.     char **modeArgv, *flag;
  1284. #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
  1285.  
  1286.     /*
  1287.      * Check for the simpler fopen-like access modes (e.g. "r").  They
  1288.      * are distinguished from the POSIX access modes by the presence
  1289.      * of a lower-case first letter.
  1290.      */
  1291.  
  1292.     mode = 0;
  1293.     if (islower(UCHAR(string[0]))) {
  1294.     switch (string[0]) {
  1295.         case 'r':
  1296.         mode = O_RDONLY;
  1297.         break;
  1298.         case 'w':
  1299.         mode = O_WRONLY|O_CREAT|O_TRUNC;
  1300.         break;
  1301.         case 'a':
  1302.         mode = O_WRONLY|O_CREAT|O_APPEND;
  1303.         break;
  1304.         default:
  1305.         error:
  1306.         Tcl_AppendResult(interp,
  1307.             "illegal access mode \"", string, "\"", (char *) NULL);
  1308.         return NULL;
  1309.     }
  1310.     if (string[1] == '+') {
  1311.         mode &= ~(O_RDONLY|O_WRONLY);
  1312.         mode |= O_RDWR;
  1313.         if (string[2] != 0) {
  1314.         goto error;
  1315.         }
  1316.     } else if (string[1] != 0) {
  1317.         goto error;
  1318.     }
  1319.     *modePtr = mode;
  1320.     return string;
  1321.     }
  1322.  
  1323.     /*
  1324.      * The access modes are specified using a list of POSIX modes
  1325.      * such as O_CREAT.
  1326.      */
  1327.  
  1328.     if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
  1329.     Tcl_AddErrorInfo(interp, "\n    while processing open access modes \"");
  1330.     Tcl_AddErrorInfo(interp, string);
  1331.     Tcl_AddErrorInfo(interp, "\"");
  1332.     return NULL;
  1333.     }
  1334.     gotRW = 0;
  1335.     for (i = 0; i < modeArgc; i++) {
  1336.     flag = modeArgv[i];
  1337.     c = flag[0];
  1338.     if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
  1339.         mode = (mode & ~RW_MODES) | O_RDONLY;
  1340.         gotRW = 1;
  1341.     } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
  1342.         mode = (mode & ~RW_MODES) | O_WRONLY;
  1343.         gotRW = 1;
  1344.     } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
  1345.         mode = (mode & ~RW_MODES) | O_RDWR;
  1346.         gotRW = 1;
  1347.     } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
  1348.         mode |= O_APPEND;
  1349.     } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
  1350.         mode |= O_CREAT;
  1351.     } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
  1352.         mode |= O_EXCL;
  1353.     } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
  1354. #ifdef O_NOCTTY
  1355.         mode |= O_NOCTTY;
  1356. #else
  1357.         Tcl_AppendResult(interp, "access mode \"", flag,
  1358.             "\" not supported by this system", (char *) NULL);
  1359.         ckfree((char *) modeArgv);
  1360.         return NULL;
  1361. #endif
  1362.     } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
  1363. #ifndef macintosh
  1364. #ifdef O_NONBLOCK
  1365.         mode |= O_NONBLOCK;
  1366. #else
  1367.         mode |= O_NDELAY;
  1368. #endif
  1369. #endif
  1370.     } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
  1371.         mode |= O_TRUNC;
  1372.     } else {
  1373.         Tcl_AppendResult(interp, "invalid access mode \"", flag,
  1374.             "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
  1375.             " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
  1376.         ckfree((char *) modeArgv);
  1377.         return NULL;
  1378.     }
  1379.     }
  1380.     ckfree((char *) modeArgv);
  1381.     if (!gotRW) {
  1382.     Tcl_AppendResult(interp, "access mode must include either",
  1383.         " RDONLY, WRONLY, or RDWR", (char *) NULL);
  1384.     return NULL;
  1385.     }
  1386.     *modePtr = mode;
  1387.  
  1388.     /*
  1389.      * The calculation of fdopen access mode below isn't really correct,
  1390.      * but it doesn't have to be.  All it has to do is to disinguish
  1391.      * read and write permissions, plus indicate append mode.
  1392.      */
  1393.  
  1394.     i = mode & RW_MODES;
  1395.     if (i == O_RDONLY) {
  1396.     return "r";
  1397.     }
  1398.     if (mode & O_APPEND) {
  1399.     if (i == O_WRONLY) {
  1400.         return "a";
  1401.     } else {
  1402.         return "a+";
  1403.     }
  1404.     }
  1405.     if (i == O_WRONLY) {
  1406.     return "w";
  1407.     }
  1408.     return "r+";
  1409. }
  1410.  
  1411. /*
  1412.  *----------------------------------------------------------------------
  1413.  *
  1414.  * Tcl_PidCmd --
  1415.  *
  1416.  *    This procedure is invoked to process the "pid" Tcl command.
  1417.  *    See the user documentation for details on what it does.
  1418.  *
  1419.  * Results:
  1420.  *    A standard Tcl result.
  1421.  *
  1422.  * Side effects:
  1423.  *    See the user documentation.
  1424.  *
  1425.  *----------------------------------------------------------------------
  1426.  */
  1427.  
  1428.     /* ARGSUSED */
  1429. int
  1430. Tcl_PidCmd(dummy, interp, argc, argv)
  1431.     ClientData dummy;            /* Not used. */
  1432.     Tcl_Interp *interp;            /* Current interpreter. */
  1433.     int argc;                /* Number of arguments. */
  1434.     char **argv;            /* Argument strings. */
  1435. {
  1436.     FILE *f;
  1437.     OpenFile *oFilePtr;
  1438.     int i;
  1439.     char string[50];
  1440.  
  1441.     if (argc > 2) {
  1442.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1443.         argv[0], " ?fileId?\"", (char *) NULL);
  1444.     return TCL_ERROR;
  1445.     }
  1446.     if (argc == 1) {
  1447.     sprintf(interp->result, "%d", getpid());
  1448.     } else {
  1449.     if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) {
  1450.         return TCL_ERROR;
  1451.     }
  1452.     oFilePtr = tclOpenFiles[fileno(f)];
  1453.     for (i = 0; i < oFilePtr->numPids; i++) {
  1454.         sprintf(string, "%d", oFilePtr->pidPtr[i]);
  1455.         Tcl_AppendElement(interp, string);
  1456.     }
  1457.     }
  1458.     return TCL_OK;
  1459. }
  1460.  
  1461. /*
  1462.  *----------------------------------------------------------------------
  1463.  *
  1464.  * Tcl_PutsCmd --
  1465.  *
  1466.  *    This procedure is invoked to process the "puts" Tcl command.
  1467.  *    See the user documentation for details on what it does.
  1468.  *
  1469.  * Results:
  1470.  *    A standard Tcl result.
  1471.  *
  1472.  * Side effects:
  1473.  *    See the user documentation.
  1474.  *
  1475.  *----------------------------------------------------------------------
  1476.  */
  1477.  
  1478. /*
  1479. ** The following routines allow you to "capture" standard "output"
  1480. ** from the tcl output functions (puts stdout, etc...). This allows
  1481. ** you to put them someplace other than a file or the "terminal".
  1482. ** For example, "tickle" uses these routines to capture output and
  1483. ** display it in the Macintosh text window in which the script is
  1484. ** being executed.
  1485. **
  1486. ** 
  1487. */
  1488.  
  1489. typedef int (* PFI) () ;
  1490.  
  1491. static PFI    tcl_print_procedure = (PFI)0;
  1492.  
  1493. /*
  1494. ** Sets the current "print proc". The print proc must be a
  1495. ** function that will be called each time output is attempted
  1496. ** from within the tcl interpreter. The code in the tcl interpreter
  1497. ** looks like this:
  1498. **
  1499. **        if ( tcl_print_procedure != NULL &&
  1500. **                (filePtr->f == stderr || filePtr->f == stdout) )
  1501. **            {
  1502. **            (* tcl_print_procedure)(argv[2]);
  1503. **            }
  1504. **        else
  1505. **            {
  1506. **            ... the standard tcl output code ...
  1507. **            }
  1508. **
  1509. ** Therefore, your output proc should look like this:
  1510. **
  1511. **        my_print_proc(output_str)
  1512. **        char    *output_string;
  1513. **            {
  1514. **            ... code to output/store the C-string "output_str" ...
  1515. **            }
  1516. **
  1517. ** And your code should have initialization code that look like:
  1518. **
  1519. **        save_proc = Tcl_SetPrintProcedure(my_print_proc);
  1520. **
  1521. ** NOTE: That according to the logic above, if you set the print proc to
  1522. **       "NULL", then stdout and stderr will be used as they normally
  1523. **       would. Thus, "Tcl_SetPrintProcedure(NULL)" will "reset" the output.
  1524. **
  1525. ** The returned value "save_proc" is important if you want to
  1526. ** re-direct the output only temporarily. To reset the output
  1527. ** to the original output procedure later, use:
  1528. **
  1529. **        Tcl_SetPrintProcedure(save_proc);
  1530. */
  1531.  
  1532. PFI
  1533. Tcl_SetPrintProcedure(proc)
  1534.     PFI        proc;
  1535.     {
  1536.     PFI        result;
  1537.  
  1538.     result = tcl_print_procedure;
  1539.     tcl_print_procedure = proc;
  1540.     return result;
  1541.     }
  1542.  
  1543. /*
  1544. ** This routine returns the procedure pointer to the current
  1545. ** output proc. This allows you to compare to see if the output
  1546. ** proc is what you want. For instance:
  1547. **
  1548. **        current_print_proc = Tcl_GetPrintProcedure();
  1549. **        if (current_print_proc != my_print_proc)
  1550. **            {
  1551. **            Tcl_SetPrintProcedure(my_print_proc);
  1552. **            }
  1553. **
  1554. **        ... tcl scripting ...
  1555. **
  1556. **        Tcl_SetPrintProcedure(current_print_proc);
  1557. **
  1558. */
  1559.  
  1560. PFI
  1561. Tcl_GetPrintProcedure()
  1562.     {
  1563.     return tcl_print_procedure;
  1564.     }
  1565.  
  1566.     /* ARGSUSED */
  1567. int
  1568. Tcl_PutsCmd(dummy, interp, argc, argv)
  1569.     ClientData dummy;            /* Not used. */
  1570.     Tcl_Interp *interp;            /* Current interpreter. */
  1571.     int argc;                /* Number of arguments. */
  1572.     char **argv;            /* Argument strings. */
  1573. {
  1574.     FILE *f;
  1575.     int i, newline;
  1576.     char *fileId;
  1577.  
  1578.     i = 1;
  1579.     newline = 1;
  1580.     if ((argc >= 2) && (strcmp(argv[1], "-nonewline") == 0)) {
  1581.     newline = 0;
  1582.     i++;
  1583.     }
  1584.     if ((i < (argc-3)) || (i >= argc)) {
  1585.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1586.         "\" ?-nonewline? ?fileId? string", (char *) NULL);
  1587.     return TCL_ERROR;
  1588.     }
  1589.  
  1590.     /*
  1591.      * The code below provides backwards compatibility with an old
  1592.      * form of the command that is no longer recommended or documented.
  1593.      */
  1594.  
  1595.     if (i == (argc-3)) {
  1596.     if (strncmp(argv[i+2], "nonewline", strlen(argv[i+2])) != 0) {
  1597.         Tcl_AppendResult(interp, "bad argument \"", argv[i+2],
  1598.             "\": should be \"nonewline\"", (char *) NULL);
  1599.         return TCL_ERROR;
  1600.     }
  1601.     newline = 0;
  1602.     }
  1603.     if (i == (argc-1)) {
  1604.     fileId = "stdout";
  1605.     } else {
  1606.     fileId = argv[i];
  1607.     i++;
  1608.     }
  1609.  
  1610.     if (Tcl_GetOpenFile(interp, fileId, 1, 1, &f) != TCL_OK) {
  1611.     return TCL_ERROR;
  1612.     }
  1613.  
  1614.     if ( tcl_print_procedure != NULL &&
  1615.             (f == stderr || f == stdout) )
  1616.         {
  1617.         (* tcl_print_procedure)(argv[i]);
  1618.         if (newline) {
  1619. #if defined(THINK_C) && defined(TCLAPPL)
  1620.             (* tcl_print_procedure)("\r");
  1621. #else
  1622.             (* tcl_print_procedure)("\n");
  1623. #endif
  1624.             }
  1625.         }
  1626.     else {
  1627.         clearerr(f);
  1628.         fputs(argv[i], f);
  1629.         if (newline)
  1630.             {
  1631. #if defined(THINK_C) && defined(TCLAPPL)
  1632.             fputc('\r', f);
  1633. #else
  1634.             fputc('\n', f);
  1635. #endif
  1636.             }
  1637.         if (ferror(f))
  1638.             {
  1639.             Tcl_AppendResult(interp, "error writing \"", fileId,
  1640.                             "\": ", Tcl_PosixError(interp), (char *) NULL);
  1641.             return TCL_ERROR;
  1642.             }
  1643.         }
  1644.     
  1645.     return TCL_OK;
  1646. }
  1647.  
  1648. /*
  1649.  *----------------------------------------------------------------------
  1650.  *
  1651.  * Tcl_PwdCmd --
  1652.  *
  1653.  *    This procedure is invoked to process the "pwd" Tcl command.
  1654.  *    See the user documentation for details on what it does.
  1655.  *
  1656.  * Results:
  1657.  *    A standard Tcl result.
  1658.  *
  1659.  * Side effects:
  1660.  *    See the user documentation.
  1661.  *
  1662.  *----------------------------------------------------------------------
  1663.  */
  1664.  
  1665.     /* ARGSUSED */
  1666. int
  1667. Tcl_PwdCmd(dummy, interp, argc, argv)
  1668.     ClientData dummy;            /* Not used. */
  1669.     Tcl_Interp *interp;            /* Current interpreter. */
  1670.     int argc;                /* Number of arguments. */
  1671.     char **argv;            /* Argument strings. */
  1672. {
  1673. #ifndef macintosh
  1674.     char buffer[MAXPATHLEN+1];
  1675.  
  1676.     if (argc != 1) {
  1677.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1678.         argv[0], "\"", (char *) NULL);
  1679.     return TCL_ERROR;
  1680.     }
  1681.     if (currentDir == NULL) {
  1682.     if (getcwd(buffer, MAXPATHLEN+1) == NULL) {
  1683.         if (errno == ERANGE) {
  1684.         interp->result = "working directory name is too long";
  1685.         } else {
  1686.         Tcl_AppendResult(interp,
  1687.             "error getting working directory name: ",
  1688.             Tcl_PosixError(interp), (char *) NULL);
  1689.         }
  1690.         return TCL_ERROR;
  1691.     }
  1692.     currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1));
  1693.     strcpy(currentDir, buffer);
  1694.     }
  1695.     interp->result = currentDir;
  1696. #endif
  1697.     return TCL_OK;
  1698. }
  1699.  
  1700. /*
  1701.  *----------------------------------------------------------------------
  1702.  *
  1703.  * Tcl_ReadCmd --
  1704.  *
  1705.  *    This procedure is invoked to process the "read" Tcl command.
  1706.  *    See the user documentation for details on what it does.
  1707.  *
  1708.  * Results:
  1709.  *    A standard Tcl result.
  1710.  *
  1711.  * Side effects:
  1712.  *    See the user documentation.
  1713.  *
  1714.  *----------------------------------------------------------------------
  1715.  */
  1716.  
  1717.     /* ARGSUSED */
  1718. int
  1719. Tcl_ReadCmd(dummy, interp, argc, argv)
  1720.     ClientData dummy;            /* Not used. */
  1721.     Tcl_Interp *interp;            /* Current interpreter. */
  1722.     int argc;                /* Number of arguments. */
  1723.     char **argv;            /* Argument strings. */
  1724. {
  1725.     int bytesLeft, bytesRead, count;
  1726. #define READ_BUF_SIZE 4096
  1727.     char buffer[READ_BUF_SIZE+1];
  1728.     int newline, i;
  1729.     FILE *f;
  1730.  
  1731.     if ((argc != 2) && (argc != 3)) {
  1732.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1733.         " fileId ?numBytes?\" or \"", argv[0],
  1734.         " ?-nonewline? fileId\"", (char *) NULL);
  1735.     return TCL_ERROR;
  1736.     }
  1737.     i = 1;
  1738.     newline = 1;
  1739.     if ((argc == 3) && (strcmp(argv[1], "-nonewline") == 0)) {
  1740.     newline = 0;
  1741.     i++;
  1742.     }
  1743.     if (Tcl_GetOpenFile(interp, argv[i], 0, 1, &f) != TCL_OK) {
  1744.     return TCL_ERROR;
  1745.     }
  1746.  
  1747.     /*
  1748.      * Compute how many bytes to read, and see whether the final
  1749.      * newline should be dropped.
  1750.      */
  1751.  
  1752.     if ((argc >= (i + 2)) && isdigit(UCHAR(argv[i+1][0]))) {
  1753.     if (Tcl_GetInt(interp, argv[i+1], &bytesLeft) != TCL_OK) {
  1754.         return TCL_ERROR;
  1755.     }
  1756.     } else {
  1757.     bytesLeft = 1<<30;
  1758.  
  1759.     /*
  1760.      * The code below provides backward compatibility for an
  1761.      * archaic earlier version of this command.
  1762.      */
  1763.  
  1764.     if (argc >= (i + 2)) {
  1765.         if (strncmp(argv[i+1], "nonewline", strlen(argv[i+1])) == 0) {
  1766.         newline = 0;
  1767.         } else {
  1768.         Tcl_AppendResult(interp, "bad argument \"", argv[i+1],
  1769.             "\": should be \"nonewline\"", (char *) NULL);
  1770.         return TCL_ERROR;
  1771.         }
  1772.     }
  1773.     }
  1774.  
  1775.     /*
  1776.      * Read the file in one or more chunks.
  1777.      */
  1778.  
  1779.     bytesRead = 0;
  1780.     clearerr(f);
  1781.     while (bytesLeft > 0) {
  1782.     count = READ_BUF_SIZE;
  1783.     if (bytesLeft < READ_BUF_SIZE) {
  1784.         count = bytesLeft;
  1785.     }
  1786.     count = fread(buffer, 1, count, f);
  1787.     if (ferror(f)) {
  1788.         /*
  1789.          * If the file is in non-blocking mode, break out of the
  1790.          * loop and return any bytes that were read.
  1791.          */
  1792.  
  1793.         if ((errno == EWOULDBLOCK) && ((count > 0) || (bytesRead > 0))) {
  1794.         clearerr(f);
  1795.         bytesLeft = count;
  1796.         } else {
  1797.         Tcl_ResetResult(interp);
  1798.         Tcl_AppendResult(interp, "error reading \"", argv[i],
  1799.             "\": ", Tcl_PosixError(interp), (char *) NULL);
  1800.         return TCL_ERROR;
  1801.         }
  1802.     }
  1803.     if (count == 0) {
  1804.         break;
  1805.     }
  1806.     buffer[count] = 0;
  1807.     Tcl_AppendResult(interp, buffer, (char *) NULL);
  1808.     bytesLeft -= count;
  1809.     bytesRead += count;
  1810.     }
  1811.     if ((newline == 0) && (bytesRead > 0)
  1812. #ifdef THINK_C
  1813.         && (interp->result[bytesRead-1] == '\r')) {
  1814. #else
  1815.         && (interp->result[bytesRead-1] == '\n')) {
  1816. #endif
  1817.     interp->result[bytesRead-1] = 0;
  1818.     }
  1819.     return TCL_OK;
  1820. }
  1821.  
  1822. /*
  1823.  *----------------------------------------------------------------------
  1824.  *
  1825.  * Tcl_SeekCmd --
  1826.  *
  1827.  *    This procedure is invoked to process the "seek" Tcl command.
  1828.  *    See the user documentation for details on what it does.
  1829.  *
  1830.  * Results:
  1831.  *    A standard Tcl result.
  1832.  *
  1833.  * Side effects:
  1834.  *    See the user documentation.
  1835.  *
  1836.  *----------------------------------------------------------------------
  1837.  */
  1838.  
  1839.     /* ARGSUSED */
  1840. int
  1841. Tcl_SeekCmd(notUsed, interp, argc, argv)
  1842.     ClientData notUsed;            /* Not used. */
  1843.     Tcl_Interp *interp;            /* Current interpreter. */
  1844.     int argc;                /* Number of arguments. */
  1845.     char **argv;            /* Argument strings. */
  1846. {
  1847.     FILE *f;
  1848.     int offset, mode;
  1849.  
  1850.     if ((argc != 3) && (argc != 4)) {
  1851.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1852.         " fileId offset ?origin?\"", (char *) NULL);
  1853.     return TCL_ERROR;
  1854.     }
  1855.     if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) {
  1856.     return TCL_ERROR;
  1857.     }
  1858.     if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) {
  1859.     return TCL_ERROR;
  1860.     }
  1861.     mode = SEEK_SET;
  1862.     if (argc == 4) {
  1863.     int length;
  1864.     char c;
  1865.  
  1866.     length = strlen(argv[3]);
  1867.     c = argv[3][0];
  1868.     if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) {
  1869.         mode = SEEK_SET;
  1870.     } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) {
  1871.         mode = SEEK_CUR;
  1872.     } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) {
  1873.         mode = SEEK_END;
  1874. #ifdef MPW
  1875.         if (offset > 0) /* UNDONE ? cover "bug?" in MPW stdio lib... */
  1876.             offset = 0;
  1877. #endif
  1878.     } else {
  1879.         Tcl_AppendResult(interp, "bad origin \"", argv[3],
  1880.             "\": should be start, current, or end", (char *) NULL);
  1881.         return TCL_ERROR;
  1882.     }
  1883.     }
  1884.     clearerr(f);
  1885.     if (fseek(f, (long) offset, mode) == -1) {
  1886.     Tcl_AppendResult(interp, "error during seek: ",
  1887.         Tcl_PosixError(interp), (char *) NULL);
  1888.     return TCL_ERROR;
  1889.     }
  1890.  
  1891.     return TCL_OK;
  1892. }
  1893.  
  1894. /*
  1895.  *----------------------------------------------------------------------
  1896.  *
  1897.  * Tcl_SourceCmd --
  1898.  *
  1899.  *    This procedure is invoked to process the "source" Tcl command.
  1900.  *    See the user documentation for details on what it does.
  1901.  *
  1902.  * Results:
  1903.  *    A standard Tcl result.
  1904.  *
  1905.  * Side effects:
  1906.  *    See the user documentation.
  1907.  *
  1908.  *----------------------------------------------------------------------
  1909.  */
  1910.  
  1911.     /* ARGSUSED */
  1912. int
  1913. Tcl_SourceCmd(dummy, interp, argc, argv)
  1914.     ClientData dummy;            /* Not used. */
  1915.     Tcl_Interp *interp;            /* Current interpreter. */
  1916.     int argc;                /* Number of arguments. */
  1917.     char **argv;            /* Argument strings. */
  1918. {
  1919.     if (argc != 2) {
  1920.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1921.         " fileName\"", (char *) NULL);
  1922.     return TCL_ERROR;
  1923.     }
  1924.     return Tcl_EvalFile(interp, argv[1]);
  1925. }
  1926.  
  1927. /*
  1928.  *----------------------------------------------------------------------
  1929.  *
  1930.  * Tcl_TellCmd --
  1931.  *
  1932.  *    This procedure is invoked to process the "tell" Tcl command.
  1933.  *    See the user documentation for details on what it does.
  1934.  *
  1935.  * Results:
  1936.  *    A standard Tcl result.
  1937.  *
  1938.  * Side effects:
  1939.  *    See the user documentation.
  1940.  *
  1941.  *----------------------------------------------------------------------
  1942.  */
  1943.  
  1944.     /* ARGSUSED */
  1945. int
  1946. Tcl_TellCmd(notUsed, interp, argc, argv)
  1947.     ClientData notUsed;            /* Not used. */
  1948.     Tcl_Interp *interp;            /* Current interpreter. */
  1949.     int argc;                /* Number of arguments. */
  1950.     char **argv;            /* Argument strings. */
  1951. {
  1952.     FILE *f;
  1953.  
  1954.     if (argc != 2) {
  1955.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1956.         " fileId\"", (char *) NULL);
  1957.     return TCL_ERROR;
  1958.     }
  1959.     if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) {
  1960.     return TCL_ERROR;
  1961.     }
  1962.     sprintf(interp->result, "%d", ftell(f));
  1963.     return TCL_OK;
  1964. }
  1965.  
  1966. /*
  1967.  *----------------------------------------------------------------------
  1968.  *
  1969.  * Tcl_TimeCmd --
  1970.  *
  1971.  *    This procedure is invoked to process the "time" Tcl command.
  1972.  *    See the user documentation for details on what it does.
  1973.  *
  1974.  * Results:
  1975.  *    A standard Tcl result.
  1976.  *
  1977.  * Side effects:
  1978.  *    See the user documentation.
  1979.  *
  1980.  *----------------------------------------------------------------------
  1981.  */
  1982.  
  1983.     /* ARGSUSED */
  1984. int
  1985. Tcl_TimeCmd(dummy, interp, argc, argv)
  1986.     ClientData dummy;            /* Not used. */
  1987.     Tcl_Interp *interp;            /* Current interpreter. */
  1988.     int argc;                /* Number of arguments. */
  1989.     char **argv;            /* Argument strings. */
  1990. {
  1991.     int count, i, result;
  1992.     double timePer;
  1993. #ifdef macintosh
  1994.  
  1995.     unsigned long    start, stop;
  1996.  
  1997. #else
  1998.  
  1999. #if NO_GETTOD
  2000.     struct tms dummy2;
  2001.     long start, stop;
  2002. #else
  2003.     struct timeval start, stop;
  2004.     struct timezone tz;
  2005.     int micros;
  2006. #endif
  2007.  
  2008. #endif    /* macintosh */
  2009.  
  2010.     if (argc == 2) {
  2011.     count = 1;
  2012.     } else if (argc == 3) {
  2013.     if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
  2014.         return TCL_ERROR;
  2015.     }
  2016.     } else {
  2017.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  2018.         " command ?count?\"", (char *) NULL);
  2019.     return TCL_ERROR;
  2020.     }
  2021. #ifdef macintosh
  2022.     start = TickCount();
  2023. #else
  2024. #if NO_GETTOD
  2025.     start = times(&dummy2);
  2026. #else
  2027.     gettimeofday(&start, &tz);
  2028. #endif
  2029. #endif
  2030.     for (i = count ; i > 0; i--) {
  2031.     result = Tcl_Eval(interp, argv[1]);
  2032.     if (result != TCL_OK) {
  2033.         if (result == TCL_ERROR) {
  2034.         char msg[60];
  2035.         sprintf(msg, "\n    (\"time\" body line %d)",
  2036.             interp->errorLine);
  2037.         Tcl_AddErrorInfo(interp, msg);
  2038.         }
  2039.         return result;
  2040.     }
  2041.     }
  2042. #ifdef macintosh
  2043.     stop = TickCount();
  2044.     timePer = ((double) (stop - start));
  2045. #else
  2046. #if NO_GETTOD
  2047.     stop = times(&dummy2);
  2048.     timePer = (((double) (stop - start))*1000000.0)/CLK_TCK;
  2049. #else
  2050.     gettimeofday(&stop, &tz);
  2051.     micros = (stop.tv_sec - start.tv_sec)*1000000
  2052.         + (stop.tv_usec - start.tv_usec);
  2053.     timePer = micros;
  2054. #endif
  2055. #endif
  2056.     Tcl_ResetResult(interp);
  2057. #ifdef macintosh
  2058.     sprintf(interp->result, "%.0lf ticks per iteration", timePer / count);
  2059. #else
  2060.     sprintf(interp->result, "%.0f microseconds per iteration", timePer/count);
  2061. #endif
  2062.     return TCL_OK;
  2063. }
  2064.  
  2065. /*
  2066.  *----------------------------------------------------------------------
  2067.  *
  2068.  * CleanupChildren --
  2069.  *
  2070.  *    This is a utility procedure used to wait for child processes
  2071.  *    to exit, record information about abnormal exits, and then
  2072.  *    collect any stderr output generated by them.
  2073.  *
  2074.  * Results:
  2075.  *    The return value is a standard Tcl result.  If anything at
  2076.  *    weird happened with the child processes, TCL_ERROR is returned
  2077.  *    and a message is left in interp->result.
  2078.  *
  2079.  * Side effects:
  2080.  *    If the last character of interp->result is a newline, then it
  2081.  *    is removed unless keepNewline is non-zero.  File errorId gets
  2082.  *    closed, and pidPtr is freed back to the storage allocator.
  2083.  *
  2084.  *----------------------------------------------------------------------
  2085.  */
  2086.  
  2087. static int
  2088. CleanupChildren(interp, numPids, pidPtr, errorId, keepNewline)
  2089.     Tcl_Interp *interp;        /* Used for error messages. */
  2090.     int numPids;        /* Number of entries in pidPtr array. */
  2091.     int *pidPtr;        /* Array of process ids of children. */
  2092.     int errorId;        /* File descriptor index for file containing
  2093.                  * stderr output from pipeline.  -1 means
  2094.                  * there isn't any stderr output. */
  2095.     int keepNewline;        /* Non-zero means don't discard trailing
  2096.                  * newline. */
  2097. {
  2098. #ifdef macintosh
  2099.  
  2100.     Tcl_AppendResult(interp, " cleanup is unimplemented", (char *) NULL);
  2101.     return TCL_ERROR;
  2102.  
  2103. #else
  2104.  
  2105.     int result = TCL_OK;
  2106.     int i, pid, length, abnormalExit;
  2107.     WAIT_STATUS_TYPE waitStatus;
  2108.  
  2109.     abnormalExit = 0;
  2110.     for (i = 0; i < numPids; i++) {
  2111.     pid = waitpid(pidPtr[i], (int *) &waitStatus, 0);
  2112.     if (pid == -1) {
  2113.         Tcl_AppendResult(interp, "error waiting for process to exit: ",
  2114.             Tcl_PosixError(interp), (char *) NULL);
  2115.         continue;
  2116.     }
  2117.  
  2118.     /*
  2119.      * Create error messages for unusual process exits.  An
  2120.      * extra newline gets appended to each error message, but
  2121.      * it gets removed below (in the same fashion that an
  2122.      * extra newline in the command's output is removed).
  2123.      */
  2124.  
  2125.     if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
  2126.         char msg1[20], msg2[20];
  2127.  
  2128.         result = TCL_ERROR;
  2129.         sprintf(msg1, "%d", pid);
  2130.         if (WIFEXITED(waitStatus)) {
  2131.         sprintf(msg2, "%d", WEXITSTATUS(waitStatus));
  2132.         Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2,
  2133.             (char *) NULL);
  2134.         abnormalExit = 1;
  2135.         } else if (WIFSIGNALED(waitStatus)) {
  2136.         char *p;
  2137.     
  2138.         p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus)));
  2139.         Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
  2140.             Tcl_SignalId((int) (WTERMSIG(waitStatus))), p,
  2141.             (char *) NULL);
  2142.         Tcl_AppendResult(interp, "child killed: ", p, "\n",
  2143.             (char *) NULL);
  2144.         } else if (WIFSTOPPED(waitStatus)) {
  2145.         char *p;
  2146.  
  2147.         p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus)));
  2148.         Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
  2149.             Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p, (char *) NULL);
  2150.         Tcl_AppendResult(interp, "child suspended: ", p, "\n",
  2151.             (char *) NULL);
  2152.         } else {
  2153.         Tcl_AppendResult(interp,
  2154.             "child wait status didn't make sense\n",
  2155.             (char *) NULL);
  2156.         }
  2157.     }
  2158.     }
  2159.     ckfree((char *) pidPtr);
  2160.  
  2161.     /*
  2162.      * Read the standard error file.  If there's anything there,
  2163.      * then return an error and add the file's contents to the result
  2164.      * string.
  2165.      */
  2166.  
  2167.     if (errorId >= 0) {
  2168.     while (1) {
  2169. #        define BUFFER_SIZE 1000
  2170.         char buffer[BUFFER_SIZE+1];
  2171.         int count;
  2172.     
  2173.         count = read(errorId, buffer, (size_t) BUFFER_SIZE);
  2174.     
  2175.         if (count == 0) {
  2176.         break;
  2177.         }
  2178.         result = TCL_ERROR;
  2179.         if (count < 0) {
  2180.         Tcl_AppendResult(interp,
  2181.             "error reading stderr output file: ",
  2182.             Tcl_PosixError(interp), (char *) NULL);
  2183.         break;
  2184.         }
  2185.         buffer[count] = 0;
  2186.         Tcl_AppendResult(interp, buffer, (char *) NULL);
  2187.     }
  2188.     close(errorId);
  2189.     }
  2190.  
  2191.     /*
  2192.      * If a child exited abnormally but didn't output any error information
  2193.      * at all, generate an error message here.
  2194.      */
  2195.  
  2196.     if (abnormalExit && (*interp->result == 0)) {
  2197.     Tcl_AppendResult(interp, "child process exited abnormally",
  2198.         (char *) NULL);
  2199.     }
  2200.  
  2201.     /*
  2202.      * If the last character of interp->result is a newline, then remove
  2203.      * the newline character (the newline would just confuse things).
  2204.      * Special hack: must replace the old terminating null character
  2205.      * as a signal to Tcl_AppendResult et al. that we've mucked with
  2206.      * the string.
  2207.      */
  2208.  
  2209.     length = strlen(interp->result);
  2210.     if (!keepNewline && (length > 0) && (interp->result[length-1] == '\n')) {
  2211.     interp->result[length-1] = '\0';
  2212.     interp->result[length] = 'x';
  2213.     }
  2214.  
  2215.     return result;
  2216. #endif
  2217. }
  2218.